﻿
'Copyright  ©  2010  Linda A. Tedrow

'Permission is hereby granted, free of charge, to any person obtaining a copy
'of this software and associated documentation files (the "Software"), to deal
'in the Software without restriction, including without limitation the rights
'to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
'copies of the Software, and to permit persons to whom the Software is
'furnished to do so, subject to the following conditions:

'The above copyright notice and this permission notice shall be included in
'all copies or substantial portions of the Software.


'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
'EXPRESS OR 'IMPLIED, INCLUDING BUT NOT LIMITED TO THE 
'WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 
'PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
'COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
'LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
'ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE 
'USE OR OTHER DEALINGS IN THE SOFTWARE.

' * * * * * * * * *

Option Explicit

'Global Variables

Dim objTheForm, objTheForm2, objfrmShapeFile, objTheControls
Dim objTheControls2
Dim objSelectedLayer, selectedRecords
Dim intMinBM, intMaxBM
Dim optionControls, ctrls,ctrls2
Dim shpOptContrls
Dim arraySize(25)
Dim totalCount
Dim locationNum
Dim dblx, dbly
Dim d84count, d50count
Dim OpSys, MapPath, DataPath
Dim myObjLayer, txtShapeFileFullName, pRS, dummy 

'Profile Variables
Dim objXSForm, objXSControls, objXSControlPg2, objXSControlPg3
Dim anumXSArray()
Dim intArrayMax, dblXSInc, booXSDirection
Dim txtTapeStart, txtTapeEnd, txtDesiredNum 
'Discharge Variables
Dim objQwForm, objQwControls, objQwControlPg2, objQwControlPg3
Dim objQwControlPg4
Dim strDistUnits, strVeloUnits, strQwUnits
Dim anumQWArrayV()
Dim incrementDir, tapeDir, caseQi, dblQwStp
Dim dblStrmW
Dim dblSectionW, dblMidPt
Dim intQWArrayCt
Dim dblStrmRWE, dblStrmLWE, intNumMeasures
Dim dblVi, dblLi, dblWi,dblQi
Dim intVArrayCt,intVMsrCt, dblVDist
Dim dblDistance, intSectCt
Dim txtVelocity

'*******
'startStreamAss - This procedure is called during the onload event when the
'       strAssApplet is initiated.  This procedure determines which operating
'       system is in use and if there are folders for maps, shapefiles and 
'       textfiles. If these do not exist, they are created.  If the operating
'       system is WindowsMobile and does not include a My Documents folder, it
'       informs the user and exits the procedure.  
'*******
Sub startStreamAss
  ' the operating system is essential in many of the tools
  ' The Operating System number 2 is Windows2000/NT/VISTA
  ' The Operating System number 3 is WindowsMobile/WindowsCE/PocketPC2002
  OpSys =  Application.System.Properties("platformid")

  'Declare and set the object
  Dim fs, fsFolder
  
  Select Case OpSys
  'Windows VISTA
	Case 2	
      Set fs = CreateObject("Scripting.FileSystemObject")
		if not fs.folderExists("C:\strAss") then
          set fsFolder = fs.CreateFolder("C:\strAss")
    	end if 
		MapPath = "C:\StrAss"
				
		if not fs.folderExists("C:\strAss\dataFiles") then
          set fsFolder = fs.CreateFolder("C:\strAss\dataFiles")
    	end if 
		DataPath = "C:\StrAss\dataFiles"
        'Windows VISTA
           'end this case
   'WindowsMobile/WindowsCE
	Case 3	
      Dim booFileInfo
      Set fs = Application.CreateAppObject("File")
      
      if fs.exists("My Documents") then
        booFileInfo = True
      else
        msgbox ("User you need a 'My Documents' Folder")
      end if

      if fs.exists("My Documents\streamAssessment")  then
        MapPath = "My Documents\streamAssessment"
'user notification
        'msgbox "your map path is : " & MapPath
      else
        booFileInfo = fs.CreateDirectory("My Documents\streamAssessment") 
        if booFileInfo then 
          MapPath = "My Documents\streamAssessment"
          msgbox "the Created map path is : " & MapPath
        end if
      end if

      if fs.exists("My Documents\streamAssessment\datafiles")  then
         DataPath = "My Documents\streamAssessment\datafiles"
      else
         booFileInfo = fs.CreateDirectory("My Documents\streamAssessment\datafiles") 
         if booFileInfo then 
           DataPath = "My Documents\streamAssessment\datafiles"
           msgbox "the Created data path is : " & DataPath
        end if
      end if
     'WindowsMobile/WindowsCE
    End Select    ' end this case
  Set fs = nothing	
  Set fsFolder = nothing	
End Sub

'* **********************************************
'The following Sub(s) are for the Create New Shapefile Tool
'*******
'createNewShapeFile() - This procedure is called when the new shapefile icon of 
'    the strAss Toolbar is tapped.  This procedure opens the form.  
'*******
Sub createNewShapeFile()
  Applet.Forms("frmSH").show
End Sub

'*******
'createShapeFile - This procedure is called by the CREATE button in the Create
'     New Shapefile Tool.  It verifies that the user has entered a a name into 
'     the text box; if a name has not been entered, the user is informed and the
'     system exits the procedure.  This procedure then determines the shapefile
'     types needed and calls the functions to build these shapefiles.  The 
'     shapefile names are given two character suffixes that indicate the tool 
'     for which they will store data.  
'*******
Sub createShapeFile
  Dim pRS, strCurrDir, theControl, allControls
  Dim txtShapeName, txtShapeFilePrefix
  dim filesys, shpNameExists, txtShapeFileName
  Dim path, pThePage
  Dim geoMorfShapeType
  '++ create the recordset object
  Set pRS = Application.CreateAppObject ("RecordSet")
  '++ create a shapefile and add some fields
  Set pThePage = Applet.Forms("frmSH").Pages("pgShapeFile")
     'There must be a name in the txtbox or else the name is blank.shp
     ' perhaps there should be a character length.
  If pThePage("txtShapeFile").value <> "" then
    txtShapeName = pThePage("txtShapeFile").value
  Else
    msgbox ("a file name is required")
    exit sub
  End If
  '**************** ***************** *************
  txtShapeFilePrefix = mapPath & "\" & txtShapeName 
    ' the next command line determines the fields in the shapefile
  geoMorfShapeType = pThePage("list1").value
    ' the following command creates a shapefile with the 
    ' Use the method for recordset "Create" to make new shapefile

  If geoMorfShapeType = 1  or geoMorfShapeType = 5 Then  
     shpNameExists = shpFileExists(txtShapeName & "_GS.shp")
     if shpNameExists = false then
       dummy = create_GS(txtShapeFilePrefix)
       txtShapeFileName = txtShapeName & "_GS.shp"
     else 
     exit sub
    End if
  End if 

  If geoMorfShapeType = 2 or   geoMorfShapeType = 5 Then 
     shpNameExists = shpFileExists(txtShapeName & "_XS.shp")
     if shpNameExists = false then
        dummy = create_XS(txtShapeFilePrefix)
        txtShapeFileName = txtShapeName & "_XS.shp"
    else 
     exit sub
    End if
  End if

  If geoMorfShapeType = 3 or   geoMorfShapeType = 5 Then 
     shpNameExists = shpFileExists(txtShapeName & "_QW.shp")
     if shpNameExists = false then
        dummy = create_QW(txtShapeFilePrefix)
        txtShapeFileName = txtShapeName & "_QW.shp"
   else 
     exit sub
    End if
  End if
    
  If geoMorfShapeType = 4 or  geoMorfShapeType = 5 Then 
    shpNameExists = shpFileExists(txtShapeName & "_FN.shp")
     if shpNameExists = false then
        dummy = create_FN(txtShapeFilePrefix)
        txtShapeFileName = txtShapeName & "_FN.shp"
    else 
     exit sub
    End if
  End If

  Dim pTheCheckBox
  Set pTheCheckBox = pThePage.Controls("check1")

  ' the following lines of code are used to make shapefile the editable layer.
  ' This code provided some grief.  
  ' It needed to be added after the addLayerFromfile -- duh
  '  It may have also needed to be added after the free objects code. 
  '***************
  'GeoXH finds an error here
  '***************
' geomorfshapetype 1 - 4 is for individual tool
' geomorfshapetype 5 is for all tools
  If not geoMorfShapeType = 5 Then 
    If pTheCheckBox.value = True then
      Dim tf
      tf= Application.Map.Layers(txtShapeFileName).Editable 
      If tf = False then
        Set myobjLayer = Map.Layers(txtShapeFileName)
        If myObjLayer.CanEdit then
          myObjLayer.Editable   = True
        End If
      End If
    End If
  End If
 ' verify that the shape file was made
  Select Case OpSys
	Case 2
       Set filesys = CreateObject("Scripting.FileSystemObject")
         path = filesys.GetAbsolutePathName(txtShapeFileFullName)
        If filesys.FileExists(path) Then
         'user notification
        ' msgbox ("Your shapefile, '" & txtShapename & "', has been created.")
           Applet.Forms("frmSH").Close (True)
        Else
          msgbox ("Your shapefile, '" & txtShapename & "', has a problem.")
        End If
	Case 3
     Set filesys = Application.CreateAppObject("File")
     If filesys.Exists(txtShapeFileFullName) Then
       msgbox ("Your shapefile, '" & txtShapename & "', has been created.")
       Applet.Forms("frmSH").Close (True)
     Else
       msgbox ("Your shapefile, '" & txtShapename & "', has a problem.")
     End If
  End Select
End Sub  ' createShapeFile

'*****************
' check to see if shape file name exists
'********************
'Function shpFileExists(fileName) - This function parses through the computer
'         system file directory to determine if a shapefile with the name 
'         provided by the filename variable exists.  This function is called by
'         the createNewShapeFile() procedure.  
'*******
Function shpFileExists(fileName)
  dim fs, myShapeFileName
  'user notification
        'msgbox "my filename is : "  & fileName
  Select Case OpSys
	Case 2
       myShapeFileName = MapPath & "\" & fileName 
       msgbox myshapefilename
       Set fs = CreateObject("Scripting.FileSystemObject")
        if fs.fileExists(myShapeFileName) then
           msgbox ("The shapefile name: , '" & filename & "', is a duplicate.")
           ShpfileExists = true
        Else
          ShpfileExists = false 
        End If
	Case 3
       myShapeFileName = MapPath & "\" & fileName 
       msgbox myshapefilename
       Set fs = Application.CreateAppObject("File")
        if fs.Exists(myShapeFileName) then
           msgbox ("The shapefile name: , '" & filename & "', is a duplicate.")
           ShpfileExists = true
        Else
          ShpfileExists = false 
        End If
  End Select
End Function ' shpFileExists()

'*****************
' check to see if text file name exists
'********************
'Function txtFileExists(fileName) - This function parses through the computer 
'         system file directory to determine if a textfile with the name provided
'         by the filename variable exists.  This function is called by the 
'         recordQwTextFile procedure.  
'*******
Function txtFileExists(fileName)
  dim fs, mytextFileName
  Select Case OpSys
	Case 2
       mytextFileName = DataPath & "\" & fileName 
       'msgbox mytextFileName
       Set fs = CreateObject("Scripting.FileSystemObject")
        if fs.fileExists(mytextFileName) then
           msgbox ("The textfile name: , '" & filename & "', is a duplicate.")
           txtfileExists = true
        Else
          txtfileExists = false 
        End If
	Case 3
       myTextFileName = DataPath & "\" & fileName 
       msgbox mytextfilename
       Set fs = Application.CreateAppObject("File")
        if fs.Exists(myTextFileName) then
           msgbox ("The textfile name: , '" & filename & "', is a duplicate.")
           txtfileExists = true
        Else
          txtfileExists = false 
        End If
  End Select
End Function

' pebble count - grain size analysis
'*******
'Function create_GS(txtShapeFilePrefix) - This function creates a shapefile with
'         the user provided name and then creates the fields that correspond with
'         the Grain Size Analysis Tool.  
'*******
Function create_GS(txtShapeFilePrefix)
  Set pRS = Application.CreateAppObject ("RecordSet")

    'set up names
    txtShapeFileFullName = txtShapeFilePrefix & "_GS.shp"

    'create shape file
    Call pRS.Create (txtShapeFileFullName, apShapePoint)
    ' build fields for appropriate tool 
    Call pRS.Fields.Append ("ID", apFieldNumeric, 4, 0)
    Call pRS.Fields.Append ("D50", apFieldNumeric, 4, 0)
    Call pRS.Fields.Append ("D50text",  apFieldCharacter, 25, 0)
    Call pRS.Fields.Append ("D84", apFieldNumeric, 4, 0)
    Call pRS.Fields.Append ("D84text" , apFieldCharacter, 25, 0)
    Call pRS.Fields.Append ("count_n", apFieldNumeric, 4, 0)
    Call pRS.Fields.Append ("x", 5, 12, 6)
    Call pRS.Fields.Append ("y", 5, 12, 6)
    '   ++ free objects
    Set pRS = Nothing
    Call Map.AddLayerFromFile (txtShapeFileFullName)
    Dummy = true
End Function

' cross section - profile
'*******
'Function create_XS(txtShapeFilePrefix) - This function creates a shapefile with
'        the user provided name and then creates the fields that correspond with 
'        the Profile Tool.  
'*******
Function create_XS(txtShapeFilePrefix)
  Set pRS = Application.CreateAppObject ("RecordSet")
    'set up names
    txtShapeFileFullName = txtShapeFilePrefix & "_XS.shp"
    'create shape file
    Call pRS.Create (txtShapeFileFullName, apShapePoint)
    ' build fields for appropriate tool 
    Call pRS.Fields.Append ("ID", apFieldNumeric, 4, 0)
    Call pRS.Fields.Append ("Date_", apFieldDate, 8, 0)
    Call pRS.Fields.Append ("Local_Time", apFieldCharacter, 11, 0)
    Call pRS.Fields.Append ("Prpndclr", apFieldBoolean, 4, 0)  
    Call pRS.Fields.Append ("Distance", apFieldNumeric, 4, 0)
    Call pRS.Fields.Append ("Depth", apFieldNumeric, 4, 0)
    Call pRS.Fields.Append ("XS_Units", apFieldCharacter, 1, 0)
    Call pRS.Fields.Append ("x", 5, 12, 6)
    Call pRS.Fields.Append ("y", 5, 12, 6)
   ' ++ free objects
    Set pRS = Nothing
    Call Map.AddLayerFromFile (txtShapeFileFullName)
    Dummy = true
End Function
 
'*******
'Function create_QW(txtShapeFilePrefix) - This function creates a shapefile with
'         the user provided name and then creates the fields that correspond with
'         the Discharge Tool.  
'*******
Function create_QW(txtShapeFilePrefix)
  Set pRS = Application.CreateAppObject ("RecordSet")
    'set up names
    txtShapeFileFullName = txtShapeFilePrefix & "_QW.shp"
    'create shape file
    Call pRS.Create (txtShapeFileFullName, apShapePoint)
    ' build fields for appropriate tool 
     Call pRS.Fields.Append ("ID", apFieldNumeric, 4, 0)
     Call pRS.Fields.Append ("Date_", apFieldDate, 8, 0)
     Call pRS.Fields.Append ("startTime", apFieldCharacter, 12, 0)
     Call pRS.Fields.Append ("StreamName", apFieldCharacter, 15, 0)
     Call pRS.Fields.Append ("LocName", apFieldCharacter, 15, 0)
     Call pRS.Fields.Append ("StageHt", apFieldNumeric,  6,2)
     Call pRS.Fields.Append ("StartEdge", apFieldNumeric,  6,2)
     Call pRS.Fields.Append ("EndEdge", apFieldNumeric,  6,2)
'distance
     Call pRS.Fields.Append ("DUnits", apFieldCharacter, 1, 0)
'velocity
     Call pRS.Fields.Append ("VUnits", apFieldCharacter, 4, 0)
'discharge
     Call pRS.Fields.Append ("QUnits", apFieldCharacter, 3, 0)
'direction
     Call pRS.Fields.Append ("MDirection", apFieldCharacter, 3, 0)
     Call pRS.Fields.Append ("StrmWdth", apFieldNumeric, 6,2)
     Call pRS.Fields.Append ("SctnWdth", apFieldNumeric,  6,2)
     ' how to make floats
     Call pRS.Fields.Append ("Qw", 5, 6,2)
     Call pRS.Fields.Append ("Qw_stdDev", apFieldNumeric, 6,2)
     Call pRS.Fields.Append ("Description", apFieldCharacter, 255, 0)
     Call pRS.Fields.Append ("Observer1", apFieldCharacter, 25, 0)
     Call pRS.Fields.Append ("Observer2", apFieldCharacter, 25, 0)
     Call pRS.Fields.Append ("x", 5, 12, 6)
     Call pRS.Fields.Append ("y", 5, 12, 6)
     '   ++ free objects
     Set pRS = Nothing
Call Map.AddLayerFromFile (txtShapeFileFullName)
Dummy = true
End Function

'***********
' Function create_FN(txtShapeFilePrefix) - This function creates a shapefile 
'          with the user provided name and then creates the fields that 
'          correspond with the Field Note Tool.  
'*******
Function create_FN(txtShapeFilePrefix)
Set pRS = Application.CreateAppObject ("RecordSet")
    'set up names
    txtShapeFileFullName = txtShapeFilePrefix & "_FN.shp"
    'create shape file
    Call pRS.Create (txtShapeFileFullName, apShapePoint)
    ' build fields for appropriate tool 
     Call pRS.Fields.Append ("ID", apFieldNumeric, 4, 0)
     Call pRS.Fields.Append ("Date_", apFieldDate, 8, 0)
     Call pRS.Fields.Append ("strTime", apFieldCharacter, 12, 0)
     Call pRS.Fields.Append ("myNote",  apFieldCharacter, 255, 0)
     Call pRS.Fields.Append ("x", 5, 12, 6)
     Call pRS.Fields.Append ("y", 5, 12, 6)
'   ++ free objects
    Set pRS = Nothing
Call Map.AddLayerFromFile (txtShapeFileFullName)
Dummy = true
End Function

'***********
'Function verifyLayer(Layername) - This function is obsolete.  
'        This function determines if there is a file in the computer system 
'        with the name provided by the variable, Layername.  It is replaced
'        by a line of code that queries the existence of the file in the computer
'        directory system in the procedure createShapeFile.  
'******
Function verifyLayer(Layername)
  Dim lyr, lyrCurrent
  Set lyr = Nothing
  Dim myCount
  myCount = 0  
  For Each lyrCurrent In Map.Layers
    If (LCase(lyrCurrent.Name)) = (LCase(Layername)) Then
      myCount = (myCount + 1)
    End If
  Next
  If myCount > 0 then
    verifyLayer = True
  End If
End Function

'***********
'Profile Measurement
'*******************
'openFormXS - This procedure is called when the Profile icon of the strAss Toolbar
'         is tapped. The mapLayer Count Function is called; if the return value is
'         greater than zero, this procedure opens the form.  
'*******
Sub openFormXS
  'Called when the profile button is clicked/tapped
  'If there are no layers in the map, then exit.
  Dim myMapLayerCount
  ' call to Function "MapLayerCount"
  myMapLayerCount = mapLayerCount
  If myMapLayerCount > 0 Then
  
    ' show the form.
     Applet.Forms("frmXS").show
  End If
End Sub

'*******
'setInitialLayerXS - This procedure is called during the the Profiling Tool Form
'     onload event.  In this procedure, global variables are set to define forms
'     and control objects.  Initial data-entry text boxes are set to null values
'     or zeros.  This procedure then determines if an editable map layer exists
'     and if this map layer or shape file contains the corresponding fields for
'     this tool.  If these quality control requirements are not met, the user is
'     informed and the procedure is exited.  The returnNextID function is called
'     and the identity field of the shapefile record is updated.  
'*******
Sub setInitialLayerXS
  Set objXSForm = ThisEvent.Object
  Set objXSControls = objXSForm.Pages("XS_setup").Controls
      ' determine if one layer is an editable layer
    Dim objSelLayer
    ' The layer being edited is -- objSelLayer  --
    'Get the layer of the selected feature
    Set objSelLayer = Map.SelectionLayer
    'If there is no selection, exit the Sub
    If objSelLayer Is Nothing Then 
      MsgBox "No feature has been selected.", vbInformation, "No Selection"
      Applet.Forms("frmXS").Close (True) 
      Exit Sub
    End If
  Dim F, intNumericFields
  intNumericFields = 0
  For each F in objSelLayer.Records.Fields
    If F.Name = Ucase( "distance") Then  
        intNumericFields = intNumericFields + 1
    End If
    If F.Name = Ucase( "depth") Then  
        intNumericFields = intNumericFields + 1
    End If  
    If F.Name = Ucase( "xs_units") Then  
        intNumericFields = intNumericFields + 1
    End If  
  Next
  'If the required fields do not exist send a warning.
  If intNumericFields < 3 Then
    MsgBox "The selected layer does not contain Profile measurement fields.", vbExclamation, "No Numeric Fields"
    Applet.Forms("frmxs").Close (True)
    Exit Sub
  End if

  objXSControls ("txtStation").value = ""
  objXSControls("txtStageHt").value = ""
  objXSControls("txtStartVal").value = ""
  objXSControls("txtEndVal").value = ""
  objXSControls("txtDesiredNum").value = ""
  objXSControls("Check1").Value = True
  objXSControls("Check2").value = False
  booXSDirection = True	

  Dim pRS 
  Set pRS = Map.SelectionLayer.Records
  pRS.Bookmark = Map.SelectionBookmark 
  Dim ptNumValue
  ptNumValue = ReturnNextID(pRS, "ID")

  pRS.Fields("ID").value = ptNumValue
  pRS.update
  If (ptNumValue <>0 ) then
    objXSControls("txtID").value = ptNumValue
  End If
  Set prs = nothing
End Sub

'*******
'profileDirectionPerpendicular This procedure is called when the profile direction
'        radio buttons are checked.  The VB Script in ArcPad does not work radio
'        buttons as a more sophisticated code would. This procedure is a workaround
'        that appears to user as expected.  
'*******
Sub profileDirectionPerpendicular	
  objXSControls("Check1").value = True 
  objXSControls("Check2").value = False	
  booXSDirection = True	
End Sub

'*******
'profileDirectionParallel - This procedure is called when the profile direction radio
'        buttons are checked.  The VB Script in ArcPad does not work radio buttons
'        as a more sophisticated code would.  This procedure is a workaround that
'        appears to user as expected.  
'*******
Sub profileDirectionParallel
    objXSControls("Check1").value = False 
	objXSControls("Check2").value = True
    booXSDirection = False
End Sub

'*******
'go2pg2 - This procedure is called by the GO button on the first page of the
'        Profiling Tool.  It checks for required numeric values; if any of 
'        the values are missing or in the wrong format, the user is informed 
'        and the system exits the procedure.  The second page of the Profiling 
'        Tool forms is activated.  
'*******
Sub go2pg2
  'This procedure is called when the "Go" button is tapped.
  'The Go Button is on the first page of the Profiling Tool
  ' This page is named Profiling Tool as well -- maybe should change.

 if not isnumeric (objXSControls("txtStartVal").value) then
  msgbox  "Your starting value must be a number"
  exit sub
 end if

if not isnumeric (objXSControls("txtEndVal").value) then  
  msgbox  "Your ending value must be a number"
  exit sub
 end if

 if not isnumeric (objXSControls("txtDesiredNum").value) then  
  msgbox  "Please enter the number of measurement you will record"
  exit sub
 end if

 call setUpProfile
 objXSForm.Pages("XS_record").Activate
End Sub

'*******
'setUpProfile - This procedure is called by the go2pg2 procedure of the Profiling
'      Tool.  It forwards the required values from the first page to the second page.
'      In this procedure the incrementing values are calculated and the array
'      anumXSArray is defined using the number of measurements to be collected 
'      provided by the user.  
'*******
Sub setUpProfile
  'get values from Page 1
  txtTapeStart = objXSControls("txtStartVal").value
  txtTapeEnd = objXSControls("txtEndVal").value
  txtDesiredNum = objXSControls("txtDesiredNum").value
  'msgbox (txtTapeStart & "to" &  txtTapeEnd)
   
  Dim theFirstMeasure
  theFirstMeasure = 1

  Set objXSControlPg2 = objXSForm.Pages("XS_record").Controls
  objXSControlPg2 ("txtXSDist").value = txtTapeStart 
  objXSControlPg2("txtXSEnd").value =  txtTapeEnd
  objXSControlPg2 ("txtXSCountM").value = theFirstMeasure
  objXSControlPg2 ("txtXSHt").value = ""
  Dim calcNext

  If txtTapeEnd <> 1 then
    'dblXSInc = round((txtTapeEnd - txtTapeStart) / (txtDesiredNum - 1),1)
    dblXSInc = round((txtTapeEnd - txtTapeStart) / (txtDesiredNum ),1)
    calcNext = Round((dblXSInc  + txtTapeStart),1)
  Else
    calcnext = 2
    msgbox "Do you want me to increment Tape Distance For you?"
  End If

  objXSControlPg2("txtXSNextDist").value =  calcNext   
  ' use the desired number of measurements to Set up array
  intArrayMax = txtDesiredNum - 1
  redim anumXSArray(3,intArrayMax)
End Sub 'setUpProfile

'***************
'nowReadXSArray() - This procedure is called by the VIEW button in the Profiling
'      Tool.  It parses through the anumXSArray and shows the profile measures
'      in a text box.  
'*******
Sub nowReadXSArray()
  ' This shows array of profile measures in text box.  
  Dim intXSIndex
  Dim strXSMsg
  intXSIndex = 0

  For intXSIndex = 0 to cint(intArrayMax) 
    strXSMsg = strXSMsg & anumXSArray(0,intXSIndex) & ",  "  
    strXSMsg = strXSMsg & anumXSArray(1,intXSIndex) & ",  "
    strXSMsg = strXSMsg & anumXSArray(2,intXSIndex) & vbNewLine 
  Next
  objXSControlPg2 ("txtXSRecord").value  =  strXSMsg
  'msgBox strXSMsg
End Sub 'nowReadXSArray

'*******
'record_XSmeasure - This  procedure is called by the RECORD button of the Record
'       Page in the Profiling Tool.  This procedure is called each time a measurement
'      is recorded.  The procedure checks for the required values and determines if
'      the values are in the correct format.  If not, the user is informed and the
'      system exits the procedure.  After these quality checks, three values (count,
'      distance, and height) are added to the array anumXSArray and the page is
'      reset for the next measurement. 
'*******
Sub record_XSmeasure
  ' These are the three values for each profile measure
  Dim intXScount
  Dim dblXSdistance
  Dim dblXSHeight
  ' error check for units of measure.  
  if objXSControlPg2 ("lstXSUnit").value = "" then
    msgbox "what are the measuring units?"
    exit sub
  end if 
  intXScount = cInt(objXSControlPg2 ("txtXSCountM").value)

  ' error check  - - is value in text box a number
  If IsNumeric (objXSControlPg2 ("txtXSDist").value) then
    dblXSdistance = cdbl(objXSControlPg2 ("txtXSDist").value)
  Else
    msgbox "Please enter tape distance with numbers"
  End If

  If IsNumeric (objXSControlPg2 ("txtXSHt").value) then
    dblXSHeight = cdbl(objXSControlPg2 ("txtXSHt").value)
  Else
    msgbox "Please enter height with numbers"
    objXSControlPg2 ("txtXSHt").setfocus
    exit sub
  End If

  ' This is presuming that the user is moving sequentially
  ' this sets values for zero based array and one based count
  Dim myXSArrayCount
  myXSArrayCount = intXScount - 1
  ' record the variables to the array 
  if myXSArrayCount > intArrayMax then
    intArrayMax = changeArraySize(intArrayMax)
  end if

  anumXSArray(0,myXSArrayCount) = intXScount 
  anumXSArray(1,myXSArrayCount) = dblXSdistance
  anumXSArray(2,myXSArrayCount) = dblXSHeight

  '***************
  'increment count
  ' The second plus 1 is so that beginning value is not counted
  ' this may need to be different.  

  Dim intStop, intMeasureDistance
  intStop = cint(intArrayMax) + 1 

  If Cint(intXSCount) = intStop then 
    msgbox "This should be your last measure"
  end if 
   'msgbox objXSControlPg2 ("txtXSDist").value 
  objXSControlPg2 ("txtXSCountM").value = intXScount + 1
  objXSControlPg2 ("txtXSDist").value = round(dblXSDistance + dblXSInc,1)
  objXSControlPg2 ("txtXSHt").value  =  ""
  intMeasureDistance = round(objXSControlPg2 ("txtXSDist").value  + dblXSInc,1)
  if cint(intMeasureDistance) <= cint(txtTapeEnd) then
    objXSControlPg2 ("txtXSNextDist").value = intMeasureDistance
  else 
    objXSControlPg2 ("txtXSNextDist").value = ""
  end if 
  objXSControlPg2 ("txtXSHt").setfocus
End Sub  'end record_XSmeasure

'*******
'Function changeArraySize(n) - This function is used to ���redim��� or resize the
'         array used in the Profile Tool. It is called by the record_XSmeasure 
'         procedure when extra measurements are collected.  
'*******
Function changeArraySize(n)
  intArrayMax = n + 1
  redim preserve anumXSArray(3,intArrayMax)
  changeArraySize = intArrayMax 
End Function

'*******
' btnXSsave - This procedure is called from the SAVE button in the Profile Tool.
'    It records the date, time, point location, maximu depth of river, the units 
'    used to collect measurements and the direction of measurements, perpendicular 
'    or parallel to the stream.  This procedure also save the values in the array,
'    anumXSArray, to a text file.  
'*******
Sub btnXSsave
  Dim strName, fileName, intLength, strNameRaw
  Dim filesys, filetxt, getname, path, strCurrDir
  Dim strXSMsg
  Dim intNameLen
  dblX = Map.PointerX
  dblY = Map.PointerY
 
  locationNum = objXSControls("txtID").value
  ' here 
  ' I have coded this as a safety catch
  ' this is quick and dirty and will need to be recoded
  ' with opitions similar to Sub recordQwTextFile

  strName = Map.SelectionLayer.Name
  intNameLen = len(strName) - 4
  strName = left(strName, intNamelen)
  '------------------------
  ' saving a text file is different on PC vs WINDOWS Mobile OS
  ' The Select Case code here is 
  ' Case 2 is for PC
  ' Case 3 is Windows Mobile
  '------------------------	
    Select Case OpSys
	    Case 2
          Set filesys = CreateObject("Scripting.FileSystemObject")
	    Case 3
          Set filesys = Application.CreateAppObject("File")
    End Select
  Select Case OpSys
	Case 2
       Dim n, dblMaxDepth       
       'strCurrDir = "c:\temp\"
       fileName = datapath & "\"  & strName & cstr(locationNum) & ".txt"
       Set filetxt = filesys.CreateTextFile(filename, True)			
       path = filesys.GetAbsolutePathName(filename)
       getname = filesys.GetFileName(path)
       dblMaxDepth = 0
       For n = 0 to cint(intArrayMax) 
         strXSMsg = strXSMsg & anumXSArray(0,n) & ",  "  
         strXSMsg = strXSMsg & anumXSArray(1,n) & ",  "
         strXSMsg = strXSMsg & anumXSArray(2,n) & vbNewLine 
         filetxt.WriteLine( strXSMsg) 
         strXSMsg = "" 
         if anumXSArray(2,n) > dblMaxDepth then
           dblMaxDepth = anumXSArray(2,n)
         end if
       Next
       filetxt.Close

      If filesys.FileExists(path) Then
        msgbox ("Your file, '" & getname & "', has been created.")
      End If
	Case 3
      Dim TextPath, TextFile
      'strCurrDir = "\My Documents\streamAssessment\"   
      TextPath =  datapath & "\" & strName & cstr(locationNum) & ".txt"
	  Set TextFile = Application.CreateAppObject("file")			
	  TextFile.Open TextPath, 2
      dblMaxDepth = 0
      For n = 0 to cint(intArrayMax) 
       strXSMsg = strXSMsg & anumXSArray(0,n) & ",  "  
       strXSMsg = strXSMsg & anumXSArray(1,n) & ",  "
       strXSMsg = strXSMsg & anumXSArray(2,n) & vbNewLine 
       TextFile.WriteLine( strXSMsg) 
       strXSMsg = "" 
       if anumXSArray(2,n) > dblMaxDepth then
         dblMaxDepth = anumXSArray(2,n)
       end if
     Next
	 TextFile.Close	
    End Select

  'record your values to shapefile
   Dim objXSRS, theXSDate, theXSTime, theXSDistance, theXSUnit
   Set objXSRS = Map.SelectionLayer.Records 
   objXSRS.Bookmark = Map.SelectionBookmark
   theXSTime = FormatDateTime(Now,vbLongTime)

   theXSDate = objXSControls("Date1").value 
   theXSDistance = objXSControls("txtEndVal").value - objXSControls("txtStartVal").value 
   theXSUnit =  objXSControlPg2("lstXSUnit").value 
   'objxsRS.addnew
   objXSRS.Fields("Date_").value = theXSDate
   objXSRS.Fields("local_Time").value = theXSTime
   objXSRS.Fields("Distance").value = theXSDistance
   objXSRS.Fields("Depth").value = dblMaxDepth
   objXSRS.Fields("XS_Units").value = theXSUnit
   objXSRS.Fields("prpndclr").value = booXSDirection

   objXSRS.Fields("x").value = dblX
   objXSRS.Fields("y").value = dblY
   
   objXSRS.update
   Set objXSRS = nothing
   Applet.Forms("frmXS").Close (True) 
   Application.ExecuteCommand("clearselected") 
End Sub ' btnXSsave
 
'****************************************
'Discharge Measurement
' This is based on the mid-section method
'****************************************
'*******
'openFormQW - This  procedure is called when the Discharge icon of the strAss
'      Toolbar is tapped.  The mapLayer Count Function is called; if the return
'      value is greater than zero, this procedure opens the form.  
'*******
Sub openFormQW
  ' This procedure just checks that a shapefile exists
  Dim myMapLayerCount
  ' call to function "MapLayerCount"
  myMapLayerCount = mapLayerCount
  If myMapLayerCount > 0 Then
    Applet.Forms("frmQW").show
  End If
End Sub

'*******
'setInitialLayerQw - This procedure is called during the the Discharge - Qw Form
'     onload event.  In this procedure, global variables are set to define forms
'     and control objects.  Initial data entry text boxes are set to null values
'     or zeros. This procedure then determines if an editable map layer exists
'     and if this map layer or shape file contains the corresponding fields for
'     this tool.  If these quality control requirements are not met, the user is
'     informed and the procedure is exited.  The returnNextID function is called
'     and the identity field of the shapefile record is updated.  
'*********
Sub setInitialLayerQw
  'Get a reference to the form and controls
  'These objects are declared globally, so this is only necessary once 
  Set objQwForm = ThisEvent.Object
  Set objQwControls = objQwForm.Pages("qw_setup").Controls
  objQwControls("txtStream").value = ""
  objQwControls("txtStation").value = ""
  objQwControls("txtStageHt").value = 0
   intNumMeasures = 1
   caseQi = 0
  ' find the next point ID value for selected maplayer
  'determine if one layer is an editable layer
  Dim objSelLayer
  'Get the layer of the selected feature
  Set objSelLayer = Map.SelectionLayer
  'If there is no selection, exit the Sub
  If objSelLayer Is Nothing Then 
      MsgBox "No feature has been selected.", vbInformation, "No Selection"
      Applet.Forms("frmqw").close      
      Exit Sub
  End If
  
  Dim F, intNumericFields
  intNumericFields = 0
  For each F in objSelLayer.Records.Fields
    If F.Name = Ucase( "stageht") Then  
        intNumericFields = intNumericFields + 1
    End If
    If F.Name = Ucase( "startedge") Then  
        intNumericFields = intNumericFields + 1
    End If  
    If F.Name = Ucase( "endedge") Then  
        intNumericFields = intNumericFields + 1
    End If  
  Next
  'If the required fields do not exist send a warning.
  If intNumericFields < 3 Then
    MsgBox "The selected layer does not contain Discharge measurement fields.", vbExclamation, "No Numeric Fields"
    Applet.Forms("frmqw").Close (True)
    Exit Sub
  End if

  Dim pRS 
  Set pRS = Map.SelectionLayer.Records
  pRS.Bookmark = Map.SelectionBookmark 
  Dim ptNumValue
  ptNumValue = ReturnNextID(pRS, "ID")

  objQwControls("txtShapeFileName").value = objSelLayer.name

  pRS.Fields("ID").value = ptNumValue
  pRS.update
  If (ptNumValue <>0 ) then
    objQwControls("txtID").value = ptNumValue
  End If
  Set prs = nothing 
  ' here we need to set up the controls for objQwControlPg2
  Set objQwControlPg2 = objQwForm.Pages("qw_description").Controls
   objQwControlPg2("txtDescription").value = ""
   objQwControlPg2("txtObserver1").value  = ""
   objQwControlPg2("txtObserver2").value = ""
   objQwControlPg2("ck_l2r").value = False
   objQwControlPg2("ck_r2l").value = False
End Sub   ' *the end of setInitialLayerQw

'*******************
' how to make check boxes work like radio buttons
' via esri arcPad guru tony zoccolillo
'*******************

'*******
'go2QwDesc() - This procedure is obsolete but left in code for reference for how
'       to use check boxes that appear to users as radio buttons; this method was
'       suggested by Tony Zoccolillo on an ESRI Forum for ArcPad.  
'*******
Sub go2QwDesc()
  dblStrmLWE = objQwControlPg2("ck_r2l").value
  dblStrmRWE = objQwControlPg2("ck_l2r").value

  objQWForm.Pages("qw_description").Activate
End Sub

'*******
'set_L2R_dir - This  procedure is called by the qw_go2Calc() procedure in the
'       Discharge Tool.  The procedure is usesd to determine if incrementing is
'       negative or positive.  
'*******
Sub set_L2R_dir
  if objQwControlPg2("ck_l2r").value = True Then
	objQwControlPg2("ck_r2l").value = False	
    dblQwstp = dblStrmLWE
  End If
  if  tapeDir = "negative" then
      caseQi = 2
  else 
     caseQi = 4
  end if
End Sub

'*******
'set_R2L_dir - This  procedure is called by the qw_go2Calc() procedure in the
 '       Discharge Tool.  The procedure is usesd to determine if incrementing is
 '       negative or positive.  
'*******
Sub set_R2L_dir
  if objQwControlPg2("ck_r2l").value = True Then
	objQwControlPg2("ck_l2r").value = False		
    dblQwstp = dblStrmRWE
  End If
  if  tapeDir = "positive" then
      caseQi = 1 
  else 
     caseQi = 3
  End if
End Sub
 
'*******
'qw_go2Calc() - This procedure is called from the NEXT button of the Description
'        Page in the Discharge Tool. During this procedure, a variable is set to
'        reflect which of the radio buttons that indicate the direction of 
'        measurements are checked.  If a radio button is not selected, the user
'        is informed and the system exits the procedure. 
'        If a radio button is selected, the corresponding procedure, set_L2R_dir
'        or set_R2L_dir, is called and then the startQwCalc procedure is called.
'*******
Sub qw_go2Calc()
  dim booR2L, booL2R 
  if caseQi = 0 then
    booR2L =  objQwControlPg2("ck_r2l").value 
    booL2R =  objQwControlPg2("ck_l2r").value
    caseQi = myCaseQi(booR2L, booL2R, tapeDir)
  end if 
    if caseQi = 0 then 
     call set_L2R_dir
     call set_R2L_dir
    end if 
  if caseQi = 0 then 
    msgbox "Are you starting on RWE or LWE?"
    call set_L2R_dir
    call set_R2L_dir
    exit sub
  else
    call startQwcalc
     objQWForm.Pages("qw_calc").Activate
  end if
End Sub

'*******
'Function myCaseQi(booR2L, booL2R, tapeDir) - This function is called by the
'         qw_go2Calc() procedure.  It is used to determine the direction of the
'         distance increments when collecting velocity measurements.  
'*******
Function myCaseQi(booR2L, booL2R, tapeDir)
if booR2L = True and booL2R = False and tapeDir = "positive" then caseQi = 1
if booR2L = False and booL2R = True  and tapeDir = "positive" then caseQi = 2
if booR2L = True and booL2R = False and tapeDir = "negative" then caseQi = 3
if booR2L = False and booL2R = True  and tapeDir = "negative" then caseQi = 4
End Function

'*******
'ckQwSetup - This procedure is called from the NEXT button of the Set Up Page
'   in the Discharge Tool. It checks for required numeric values and units and to
'   determine if the wetting edge values are logical; if any of the values are 
'   missing or in the wrong format, the user is informed and the system exits 
'   the procedure.  
'*******
Sub ckQwSetup
    ' check for number values
  if not isnumeric (objQwControls("txtStageHt").value) _ 
    or isempty (objQwControls("txtStageHt").value) then
    msgbox ("stage ht value must be a number")
    exit sub
  end if

  if isnumeric (objQwControls("txtRWE").value) then
    dblStrmRWE = cdbl(objQwControls("txtRWE").value)
  else
    msgbox ("start edge value must be a number")
    exit sub
  end if
  if isnumeric (objQwControls("txtLWE").value) then
    dblStrmLWE  = cdbl(objQwControls("txtLWE").value)
  else
    msgbox ("End edge value must be a number")
    exit sub
  end if
  if isnumeric (objQwControls("txtNumMeasures").value) then
    intNumMeasures = cdbl(objQwControls("txtNumMeasures").value)
  else
    msgbox ("number of measures must be a number")
  exit sub
  end if

  ' check for measuring units
  if objQwControls("listDunits").value = "" then
    msgbox ("what are your units -- feet or meters?")
    exit sub
  else
    strDistUnits = (objQwControls("listDunits").text)
  end if

'* * * * *
' what direction is the tape
  if dblStrmRWE < dblStrmLWE then
    tapeDir = "positive"
  elseif dblStrmRWE > dblStrmLWE then
    tapeDir = "negative"
  else
    msgbox "check you wetting edge values"
    exit sub
  end if 
  'msgbox tapeDir
  intQwArrayCt = intNumMeasures - 1
  dblStrmW = Abs(dblStrmLWE - dblStrmRWE)
  dblSectionW = dblStrmW / intNumMeasures
  'dblMidPt = dblStrmStrt + (dblSectionW / 2 )
  redim anumQWArrayV(5,intQwArrayCt )
' end check
 objQWForm.Pages("qw_description").Activate
End Sub

'*******
'startQwcalc - This procedure is called by the qw_go2calc() procedure in the
'     Discharge Tool.  The procedure loads the values needed to record velocity
'     measurements to the corresponding text boxes and it sets up the first
'     measurement location.  
'*******
Sub startQwcalc 
  Set objQwControlPg3 = objQwForm.Pages("qw_calc").Controls
  ' Stream Width
  objQwControlPg3("txtStrW").value = dblStrmW
  ' Section Width
  objQwControlPg3("txtSectionW").value = round(dblSectionW,1)
  ' the first reading
  objQwControlPg3("txtQiCount").value = 1
    
  dim dblStrmStrt 
  dblStrmStrt = dblQwStp

  'the first midpoint value

if CaseQi = 1 or CaseQi = 2 then
  ' try rounding to one digit to right of decimal
  dblMidPt = Round(dblQWStp + (dblSectionW / 2 ),1)

  objQwControlPg3("txtQiMidPt").value = dblMidPt
elseif  CaseQi = 3 or CaseQi = 4  then
  dblMidPt = dblQWStp - (dblSectionW / 2 )
  objQwControlPg3("txtQiMidPt").value = dblMidPt
else
msgbox "did not work"
end if

  objQwControlPg3("txtSectionCount").value = intNumMeasures
'  objQwControlPg3("lblUnitsL").value = strDistUnits
  'objQwControlPg3("lblUnitsL").value = strDistUnits
  objQWForm.Pages("qw_description").Activate
' what about
' can there be a on change event that calculates the observation depths?????
' if depths are less than 1 m then 60%
' else 20 & 80 and value # 2 are no longer read only.  
' and then the velocity (sub i) is the average of the two.  

End Sub
'*******************
'PopArray - This procedure is obsolete but left in code for reference to the
'           contents of the array used in the discharge tool.  
'*******
Sub PopArray
  dim n
  n = intcnt - 1
  arrayQw(n,0) = intCNT
  arrayQw(n,1) = dblLoc
  arrayQw(n,2) = dblDPTH
  arrayQw(n,3) = dblVEL
End Sub

'*******************
'  calcObservDepth() - This procedure is called from an onkillfocus event of
'    the SECTION DEPTH textbox located on the QwCalc Page in the Discharge Tool.
'    This procedure determines the height to measure velocity.  
'*******
Sub calcObservDepth()
  Dim dblSecD
  Dim dblObsD
  if isnumeric (objQwControlPg3("txtSectionD").value) then
    dblSecD = cdbl(objQwControlPg3("txtSectionD").value )
    'VELOCITY - AREA METHOD OF DISCHARAGE MEASUREMENT
    ' VELOCITY IS MEASURED 0.6d from water surface
    '                  or  0.4d from bottom
    dblObsD = dblSecD * 0.4
    objQwControlPg3("txtObDepth1").value = dblObsD
  else 
    msgbox "The depth must be a number value"
    exit sub
  end if
  
End Sub
'*******************
' calcQi() - This procedure is called from the STORE button in the Discharge Tool.
'          It uses the section depth, section width and velocity to calculate the
'          discharge for this section of a stream.  This procedure also checks the
'          measurement units and requires that they are in the same system as that
'          used to measure the distance across the stream.  The recordMeasures()
'          procedure is called and then the data entry page is setup for the 
'          next measure.  
'*******************
Sub calcQi()
  dim stru1
    ' check that variables are numeric
    if isnumeric (objQwControlPg3("txtSectionW").value) then
      dblWi = cdbl(objQwControlPg3("txtSectionW").value)
    else 
      msgbox "The section Width must be a number value"
      exit sub
    end if

    if isnumeric (objQwControlPg3("txtSectionD").value) then
      dblLi = cdbl(objQwControlPg3("txtSectionD").value) 
    else 
      msgbox "The depth must be a number value"
      exit sub
    end if

    if isnumeric (objQwControlPg3("txtVi").value) then
      dblVi = cdbl(objQwControlPg3("txtVi").value)
    else 
      msgbox "The velocity must be a number value"
      exit sub
    end if

    if isnumeric (objQwControlPg3("txtQiMidPt").value) then
      dblVi = cdbl(objQwControlPg3("txtQiMidPt").value)
    else 
      msgbox "The location must be a number value"
      exit sub
    end if

    intSectCt = cint(objQwControlPg3("txtSectionCount").value) 

    strU1 = objQwControls("listDUnits").value & "^2"
    strVeloUnits = objQwControlPg3("listUnitV").text 
    
  if strDistUnits = "Meters" and strVeloUnits = "m/sec" then
    strQWUnits = "cms"
  elseif strDistUnits = "Feet" and strVeloUnits = "ft/sec" then
    strQWUnits = "cfs"
  elseif strDistUnits = "Inches" and strVeloUnits = "ft/sec" then
    strQWUnits = "cfs"
  elseif strDistUnits = "Meters" and strVeloUnits = "cm/sec" then
    strQWUnits = "cms"
  else
    msgbox "your units do not match"
    exit sub
  end if

  if strVeloUnits = "m/sec"then
    dblQi = dblLi * dblwi * dblVi
  elseif strVeloUnits = "ft/sec" and strDistUnits = "Feet" then
    dblQi = dblLi * dblwi  * dblVi 
  elseif strVeloUnits = "cm/sec" then
    dblQi = dblLi * dblwi  * dblVi * 0.01
  elseif strVeloUnits = "ft/sec" and strDistUnits = "Inches" then
    dblQi = dblLi * dblwi  * dblVi * 0.00694
  else
    msgbox "your units do not match"
    exit sub
  end if

    intVMsrCt = CInt(objQwControlPg3("txtQiCount").value)
    intVArrayCt = intVMsrCt - 1
    dblVDist = cDbl(objQwControlPg3("txtQiMidPt").value) 

  call recordMeasures()
  objQwControlPg3("txtQiCount").value = intVMsrCt + 1

 if  caseQi = 1 or caseQi = 2 then
   dblDistance = cdbl(objQwControlPg3("txtQiMidPt").value) + dblWi
 else
   dblDistance = cdbl(objQwControlPg3("txtQiMidPt").value) - dblWi
 end if 
   objQwControlPg3("txtQiMidPt").value = dblDistance
   objQwControlPg3("txtSectionD").value = ""
   objQwControlPg3("txtobDepth1").value = ""
   objQwControlPg3("txtVi").value = ""
End Sub

'*******
'recordMeasures() - This procedure is called by the calcQi() procedure in the
'          Discharge Tool.  It stores the measured values to the anumQWArrayV array.
'*******
Sub recordMeasures()
  'msgbox intVArrayCt & vbcrlf & UBound(anumQWArrayV,2)
  if intVArrayCt > UBound(anumQWArrayV,2) then 
    redim preserve anumQWArrayV(5,intVArrayCt)
  end if 

  anumQWArrayV(0, intVArrayCt) = intVMsrCt
  anumQWArrayV(1, intVArrayCt) = dblVDist
  anumQWArrayV(3, intVArrayCt) = dblLi
  anumQWArrayV(4, intVArrayCt) = dblVi
 End Sub  

'*******
'recordQi() - This  procedure is called from the CALC DISCHARGE button in the
'        Discharge Tool.  This procedure parses through the measured values in the
'        anumQWArrayV array and calculates the discharge for each section
'        measured and stores this newly calculated value to the array and then calls
'        the the procedure viewArray and activates the last page of the Discharge Tool.
'*******
Sub recordQi()
  dim intUbound
  intUbound = UBound(anumQWArrayV,2)
  dim i
  for i = 0 to intUbound

  if i = 0 then
    anumQWArrayV(2, i) = abs(anumQWArrayV(1, i+1) - dblStrmRWE)
  elseif i = intUbound then 
    anumQWArrayV(2, i) = abs(dblStrmlWE - anumQWArrayV(1, i-1) )
  else
    anumQWArrayV(2, i) = abs (anumQWArrayV(1, i+1) -  anumQWArrayV(1, i-1))
  end if
 ' Q = v * l * w  
    anumQWArrayV(5, i) = anumQWArrayV(4, i) * anumQWArrayV(2, i) * anumQWArrayV(3, i)
  next
  call viewArray
  objQWForm.Pages("qw_view").Activate
  call clearCalc
End Sub

'**********************************************************************
'clearCalc - This  procedure is called from the recordQi() procedure
'    in the Discharge Tool.  It resets the data entry textboxes to empty values.
'*******
Sub clearCalc
  objQwControlPg3("txtSectionD").value = ""
  objQwControlPg3("txtObDepth1").value = ""
  objQwControlPg3("txtVi").value =  ""
End Sub

'**********************************************************************
'viewArray() - This procedure is called by the recordQi() procedure in the Discharge
'     Tool.  The procedure parses through the array anumQWArrayV and displays
'     its contents in a text box.  It then parses through the array and calculates
'     and displays the standard deviation of the velocity measurements.  
'*******
Sub viewArray()
  Set objQwControlPg4 = objQwForm.Pages("qw_view").Controls
  Dim strMsg, i, j, intUbound
  Dim dblQw, dblVw, dblMeanV, dblStdDev
  Dim n, dblWidth
  intUbound = UBound(anumQWArrayV,2)
   dblVw = 0
   dblQw = 0
   For i = 0 to intUBound
    'count
    strMsg = strMsg & anumQWArrayV(0,i) & ", "
    'dist    
    strMsg = strMsg & anumQWArrayV(1,i) & ", "
    ' wid
    strMsg = strMsg & anumQWArrayV(2,i) & ", "
    'depth
    strMsg = strMsg & anumQWArrayV(3,i) & ", "
    'velocity
    strMsg = strMsg & anumQWArrayV(4,i) & ", "
    'discharge
    strMsg = strMsg & anumQWArrayV(5,i) & vbCrLf 
    dblVw = dblVw + cdbl(anumQWArrayV(4,i))
    dblQw = dblQw + cdbl(anumQWArrayV(5,i))
  Next
  dblMeanV = dblVw  / ( intUBound + 1)

  'msgbox "the sum of velocities: " & dblVw & apcrlf & intUBound

  objQwControlPg4("txtViewArray").value = strMsg
  objQwControlPg4("txtQw").value = dblQw
  objQwControlPg4("lblUnitsQ").value = strQwUnits
  '
  ' here we calc std dev
  '
   'msgbox "The mean: " & dblMeanV

  dim dblSum, dblVi
  dblSum = 0

  For j = 0 to intUBound
    dblVi = anumQWArrayV(4,j) 
    dblSum = dblSum  + (( dblVi - dblMeanV) * ( dblVi - dblMeanV))
  'msgbox (dblSum & " - " & dblMeanV)
  next
  'msgbox (dblSum & " - " & dblMeanV & apcrlf & intubound )

  dblstdDEv =  sqr(dblsum / (intUBound +1) )
  objQwControlPg4("txtVstdDev").value = dblstdDev
End Sub

'*******************
'recordQwShapeFile() - This procedure is called by the btnSaveQw() procedure in
'     the Discharge Tool.  It updates the the descriptive and calculated data to the
'     fields the shape file record.  
'*******************
Sub recordQwShapeFile
   'record your values to shapefile
 
  Dim obj_Qw_RS, theDate, theTime, txtLocName
   Dim theHt, theStart, TheEnd, theDUnits, theDirection
   Dim theStreamW, theSectionW, theDescription
   Dim theStreamName, theObs1, theObs2
   Dim theQw, theStdDev
   Set obj_Qw_RS = Map.SelectionLayer.Records 
   obj_Qw_RS.Bookmark = Map.SelectionBookmark
  
   theTime = FormatDateTime(Now,vbLongTime)
  
   Set ctrls = Applet.Forms("frmQW").Pages("qw_setup").Controls
   theDate = ctrls("QwDate").value 
   txtLocName = ctrls("txtStation").value 
   theStreamName = ctrls("txtStream").value 
   locationNum = obj_Qw_RS.Fields("ID").value
   theHt = ctrls("txtStageHt").value
   theStart = ctrls("txtLWE").value
   theEnd = ctrls("txtRWE").value
   theDUnits = ctrls("listDUnits").value

  
   theSectionW = cdbl(objQwControlPg3("txtSectionW").value)
   theStreamW = cdbl(objQwControlPg3("txtStrW").value)

   ' Set objQwControlPg2 = objQwForm.Pages("qw_description").Controls
   theDescription = objQwControlPg2("txtDescription").value
   theObs1 = objQwControlPg2("txtObserver1").value
   theObs2 = objQwControlPg2("txtObserver2").value
    if objQwControlPg2("ck_r2l").value = True then
      theDirection = "R2L"
    else
      theDirection = "L2R"
    end if

   theQw =  cdbl(objQwControlPg4("txtQw").value)
   theStdDev = cdbl(objQwControlPg4("txtVStdDev").value)

   'objRS.addnew
   obj_Qw_RS.Fields("Date_").value = theDate
   obj_Qw_RS.Fields("startTime").value = theTime
   obj_Qw_RS.Fields("streamName").value = theStreamName 
   obj_Qw_RS.Fields("LocName").value = txtLocName 
   obj_Qw_RS.Fields("stageHt").value = theHT
   obj_Qw_RS.Fields("startEdge").value = theStart
   obj_Qw_RS.Fields("endEdge").value = theEnd
   obj_Qw_RS.Fields("dunits").value = theDUnits
   obj_Qw_RS.Fields("vunits").value = strVeloUnits
   obj_Qw_RS.Fields("qunits").value = strQwUnits
   obj_Qw_RS.Fields("mdirection").value = theDirection
   obj_Qw_RS.Fields("strmwdth").value = theStreamW
   obj_Qw_RS.Fields("sctnwdth").value = theSectionW
   obj_Qw_RS.Fields("descriptio").value = theDescription
   obj_Qw_RS.Fields("observer1").value = theObs1
   obj_Qw_RS.Fields("observer2").value = theObs2
   obj_Qw_RS.Fields("qw").value = theQw
   obj_Qw_RS.Fields("Qw_stdDev").value = theStdDev
   obj_Qw_RS.Fields("x").value = dblX
   obj_Qw_RS.Fields("y").value = dblY
   
   obj_Qw_RS.update
   Set obj_Qw_RS = nothing
   Applet.Forms("frmQW").Close (True) 
   Application.ExecuteCommand("clearselected") 
End Sub
 
'*******
'recordQwTextFile - This procedure is called by the btnSaveQw() procedure in the
'      Discharge Tool.  The procedure determines the operating system and the text
'      file name to be created.  Then it determines if that text file name exists.
'      If the text file exists the user is given an error message.  This is done
'      before the data is saved to the shape file to avoid duplicate points being
'      added to the shape file.  Then the system parses through array data and
'      creates a comma delimited text file that could be reused to recalculate discharge.
'*******
Sub recordQwTextFile
  Dim strName, fileName, intLength, strNameRaw
  Dim filesys, filetxt, getname, path, strCurrDir
  Dim booDummy, strQWdata
  Dim i, intUBound
  intUbound = UBound(anumQWArrayV,2)

  Select Case OpSys
	Case 2
      Set filesys = CreateObject("Scripting.FileSystemObject")
	Case 3
      Set filesys = Application.CreateAppObject("File")
  End Select
  locationNum = ctrls("txtID").value

  If ctrls("txtStation").value  <> "" then
    strName = trim(ctrls("txtStation").value) & locationNum
  elseIf ctrls("txtStream").value  <> "" then
    strName = trim(ctrls("txtStream").value) & locationNum
  Else
    strNameRaw   = ctrls("txtShapefileName").value
    intLength = len(strNameRaw) - 4
    strName = left(strNameRaw, intlength) & locationNum
  End If
 
  booDummy = txtFileExists(strName & ".txt")
  if booDummy = true then
    messagebox "This text file name exists please modify stream Name"
    exit Sub
  else

  Select Case OpSys
	Case 2
      fileName = dataPath & "\" & strName & ".txt"
      Set filetxt = filesys.CreateTextFile(filename, True)
      path = filesys.GetAbsolutePathName(filename)
      getname = filesys.GetFileName(path)
         
      For i = 0 to intUBound
        strQWdata = strQWdata & anumQWArrayV(0,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(1,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(2,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(3,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(4,i) 

        filetxt.WriteLine(strQWdata)
        ' reset the string to null
        strQWdata = ""
      Next
      ' filetxt.WriteLine("This is the pebblecount info.")
      filetxt.Close
      If filesys.FileExists(path) Then
        msgbox ("Your file, '" & getname & "', has been created.")
      End If
    Case 3
      Dim TextPath, TextFile
      TextPath =  dataPath &  "\" & strName & ".txt"
	  Set TextFile = Application.CreateAppObject("file")			
	  TextFile.Open TextPath, 2
      For i = 0 to intUBound
        strQWdata = strQWdata & anumQWArrayV(0,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(1,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(2,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(3,i) & ", "
        strQWdata = strQWdata & anumQWArrayV(4,i) 

        TextFile.WriteLine(strQWdata)
        ' reset the string to null
        strQWdata = ""
      Next
      TextFile.Close	
    End select
  End if
End Sub

'*******
'  btnSaveQw() - This procedure is called from the SAVE button in the 
'    Discharge Tool.  It determines the value of the global variables dblX and dblY
'    that store the point locations and then it calls the recordQwShapeFile and the
'    recordQwTextFile procedures.  
'*******
Sub btnSaveQw()
  dblX = Map.PointerX
  dblY = Map.PointerY
  call recordQwShapeFile
  call recordQwTextFile
  Applet.Forms("frmQW").Close (True) 
End Sub

'*********************************************************************************************************
'PebbleCount
'***********
'OpenFormGR - This  procedure is called when the Grain Size Analysis icon of the
'             strAss Toolbar is tapped.  The mapLayer Count Function is called; if the
'             return value is greater than zero, this procedure opens the form.  
'***********
Sub OpenFormGR
  'Called when the calculator button is clicked/tapped
  'If there are no layers in the map, then exit (no statistics to calculate).
  Dim myMapLayerCount
  ' call to function "MapLayerCount"
  myMapLayerCount = mapLayerCount
  If myMapLayerCount > 0 Then
    ' show the form.
    Applet.Forms("frmGR").show
    totalCount = 0
  End If
End Sub

'*******
'setInitialLayerGR - This  procedure is called during the the Grain Size Analysis
'      Form onload event.  In this procedure, global variables are set to define 
'      forms and control objects.  Initial data entry text boxes are set to null
'      values or zeros.  This procedure then determines if a editable map layer 
'      exists and if this map layer or shape file contains the corresponding 
'      fields for this tool.  If these quality control requirements are not met,
'      the user is informed and the procedure is exited.  The returnNextID function
'      is called and the identity field of the shapefile record is updated.  
'*******
Sub SetInitialLayerGR
  'Get a reference to the form and controls
  'These objects are declared globally, so this is only necessary once
  
  Set objTheForm = ThisEvent.Object
  Set objTheControls = objTheForm.Pages("onlypage").Controls
  Set optionControls = objTheForm.Pages("pcOptions").Controls
  
  objTheControls ("txtBoxD50").value = 0
  objTheControls("txtBoxD84").value = 0
  objTheControls ("Total").value = 0
  objTheControls ("txtSedType").value = 0

  'determine if one layer is an editable layer
  Dim objSelLayer
  'Get the layer of the selected feature
  Set objSelLayer = Map.SelectionLayer
  'If there is no selection, exit the Sub
  If objSelLayer Is Nothing Then 
      MsgBox "No feature has been selected.", vbInformation, "No Selection"
      Applet.Forms("frmGR").close      
      Exit Sub
  End If

  Dim F, intNumericFields
  intNumericFields = 0
  For each F in objSelLayer.Records.Fields
    If F.Name = "D50" Then  
        intNumericFields = intNumericFields + 1
    End If
    If F.Name = "D84" Then  
        intNumericFields = intNumericFields + 1
    End If  
    If F.Name = "COUNT_N" Then  
        intNumericFields = intNumericFields + 1
    End If  
  Next
  'If the required fields do not exist send a warning.
  If intNumericFields < 3 Then
    MsgBox "The selected layer does not contain D50 or D84 or count_n fields.", vbExclamation, "No Numeric Fields"
    Applet.Forms("frmGR").Close (True)
    Exit Sub
  End if

  optionControls("txtEditLayer").value = objSelLayer.name
  ' find identity of selected feature
  Dim pRS 
  Set pRS = Map.SelectionLayer.Records
  pRS.Bookmark = Map.SelectionBookmark
  Dim ptNumValue
  ptNumValue = ReturnNextID(pRS, "ID")
  'optionControls("txt").value = ptNumValue
  objTheControls("txtID").value = ptNumValue
  pRS.Fields("ID").value = ptNumValue
  pRS.update
  Set prs = nothing 
End Sub

'*******
'go2pg2_gs - This procedure is called by the START PEBBLE COUNT button on
'         the first page of the Grain Size Analysis Tool.  The second page of the Grain
'          Size Analysis Tool forms is activated.  
'*******
Sub go2pg2_gs
objTheForm.Pages("onlypage").Activate
End Sub

'*******
'Function ReturnNextID (objRS, strFieldName) - This function parses through the
'         current shapefile, recordset, and finds the maximum value in the 
'         identification field and returns this value incremented by one.  This returned
'         value becomes the key value for the new record to be created.  This function
'         is called by the SetInitialLayerGR, SetInitialLayerSN, SetInitialLayerXS, and
'         SetInitialLayerQW procedures.  
'*******
Function ReturnNextID (objRS, strFieldName)
  Dim intMax
  'Get the first record
  objRS.MoveFirst
  'Initialize the max value to the first record
  intMax = Clng(objRS.Fields(strFieldName).Value)
  'Loop through the records, updating the max value if necessary
  Dim intCurrVal
  While Not objRS.EOF
    intCurrVal = Clng(objRS.Fields(strFieldName).Value)
    If (intCurrVal > intMax) Then
      intMax = intCurrVal
    End If
    objRS.MoveNext
  Wend
objRS.MoveLast
  ReturnNextID = intMax + 1
End Function

'*******
'myCount - This  procedure is called when the selectd value in the LIST1 List box
'          of the second page of the Grain Size Analysis Tool forms is changed.  The new 
'          value is highlighted and the grain size class and the corresponding text
'          descriptions are shown in text boxes.  
'*******
Sub myCount
  Dim txtValue
  Set ctrls = Applet.Forms("frmGR").Pages("onlypage").Controls
  txtValue = ctrls("List1").value
  ctrls("txtSedType").value = txtValue
  ctrls("txtSedName").value = array2string(txtValue)
End Sub

'*******
'recordMeasure - This procedure is called by the RECORD button of the Count Your
 '          Pebbles Page in the Grain Size Analysis Tool.  This procedure is called each
 '          time a measurement is recorded and the grain size value is added to the array
 '          arraySize.  
'*******
Sub recordMeasure
  Dim total
    If ctrls("txtSedType").value = 1 then
      arraySize(1) = arraySize(1) + 1
    ElseIf ctrls("txtSedType").value = 2 then
      arraySize(2) = arraySize(2) + 1
    ElseIf ctrls("txtSedType").value = 3 then
      arraySize(3) = arraySize(3) + 1
    ElseIf ctrls("txtSedType").value =4 then
      arraySize(4) = arraySize(4) + 1
    ElseIf ctrls("txtSedType").value =5 then
      arraySize(5) = arraySize(5) + 1
    ElseIf ctrls("txtSedType").value =6 then
      arraySize(6) = arraySize(6) + 1
    ElseIf ctrls("txtSedType").value =7 then
      arraySize(7) = arraySize(7) + 1
    ElseIf ctrls("txtSedType").value =8 then
      arraySize(8) = arraySize(8) + 1
    ElseIf ctrls("txtSedType").value =9 then
      arraySize(9) = arraySize(9) + 1
    ElseIf ctrls("txtSedType").value =10 then
      arraySize(10) = arraySize(10) + 1
    ElseIf ctrls("txtSedType").value =11 then
      arraySize(11) = arraySize(11) + 1
    ElseIf ctrls("txtSedType").value =12 then
      arraySize(12) = arraySize(12) + 1
    ElseIf ctrls("txtSedType").value =13 then
      arraySize(13) = arraySize(13) + 1
    ElseIf ctrls("txtSedType").value = 14 then
      arraySize(14) = arraySize(14) + 1
    ElseIf ctrls("txtSedType").value = 15 then
      arraySize(15) = arraySize(15) + 1
    ElseIf ctrls("txtSedType").value = 16 then
      arraySize(16) = arraySize(16) + 1
    ElseIf ctrls("txtSedType").value = 17 then
      arraySize(17) = arraySize(17) + 1
    ElseIf ctrls("txtSedType").value = 18 then
      arraySize(18) = arraySize(18) + 1
    ElseIf ctrls("txtSedType").value = 19 then
      arraySize(19) = arraySize(19) + 1
    ElseIf ctrls("txtSedType").value =20 then
      arraySize(20) = arraySize(20) + 1
    ElseIf ctrls("txtSedType").value =21 then
      arraySize(21) = arraySize(21) + 1
    ElseIf ctrls("txtSedType").value =22 then
      arraySize(22) = arraySize(22) + 1
    ElseIf ctrls("txtSedType").value =23 then
      arraySize(23) = arraySize(23) + 1
    ElseIf ctrls("txtSedType").value =24 then
      arraySize(24) = arraySize(24) + 1
    ElseIf ctrls("txtSedType").value =25 then
      arraySize(25) = arraySize(25) + 1
    End If
  totalCount = totalCount + 1
  ctrls("Total").value = totalCount
  Dim i
  Dim j
  i = 0
  j = 0
  d50count = 0
  For i = 1 to 24
    d50count = d50count + arraysize(i)
    If d50count > totalcount / 2 then
      j = i
      i = 25
    End If
  Next 
  ctrls("txtBoxD50").value = j 
  '************
  ctrls("txtD50Name").value = array2string(j)
  '*********************
  Dim p
  Dim q
  p = 0
  q = 0
  d84count = 0
  For p = 1 to 24
    d84count = d84count + arraysize(p)
    If d84count > totalcount * 0.84 then
      q = p
      p = 25
    End If
  Next 
  ctrls("txtBoxD84").value = q 
  ctrls("txtD84Name").value = array2string(q)
End Sub ' end RecordMeasure

'*******
'  btnSave_Click - This  procedure is called from the SAVE button in the 
'    GrainSize Analysis Tool.  It records the point location, the size indices,
'    the text description of the size index and the number of grains measured 
'    to the shape file; it then save the values in the array to a text file; and 
'    it calls the clearGSarray procedure.  
'*******
Sub btnSave_Click
  Dim y
  dim string_d50
  dim string_d84
  dim val_d50, val_d84
  y = msgbox ("is count finished?", 4, "Wolman Pebble Count")
  If y = 6 then

  dblX = Map.PointerX
  dblY = Map.PointerY
  
    'record your values to shapefile
    Dim objRS, dbl_d50, dbl_d84, dbl_cnt
    Set objRS = Map.SelectionLayer.Records 
    objRS.Bookmark = Map.SelectionBookmark
    '  let's try right here to move previous get that id value
    ' then move forward and add one to previous
    ' now this should be the right record.  
    'copy the stored co-ords E & N values to the controls
    dbl_d50 = ctrls("txtBoxD50").value
    string_d50 =  array2string(dbl_d50)
    val_d50 =  array2val(dbl_d50)
    dbl_d84 = ctrls("txtBoxD84").value 
    string_d84 =  array2string(dbl_d84)
    val_d84 =  array2val(dbl_d84)
    dbl_cnt = ctrls("total").value 
    locationNum = objRS.Fields("ID").value
    'objRS.addnew
    objRS.Fields("D50").value = val_d50
    objRS.Fields("D50text").value = string_d50
    objRS.Fields("D84").value = val_d84
    objRS.Fields("D84text").value = string_d84
    objRS.Fields("count_n").value = dbl_cnt
    
    objRS.Fields("x").value = dblX
    objRS.Fields("y").value = dblY
   
    objRS.update
    Set objRS = nothing

    'record values to textfile
    Dim strName, fileName, intLength, strNameRaw
    Dim filesys, filetxt, getname, path, strCurrDir
    
    Select Case OpSys
	    Case 2
          Set filesys = CreateObject("Scripting.FileSystemObject")
	    Case 3
          Set filesys = Application.CreateAppObject("File")
    End Select

  If optionControls("txtReachName").value <> "" then
    strName = trim(optionControls("txtReachName").value)
  Else
    strNameRaw   = optionControls("txtEditLayer").value
    intLength = len(strNameRaw) - 4
    strName = left(strNameRaw, intlength)
  End If
  Select Case OpSys
	Case 2
      fileName = dataPath & "\" & strName & cstr(locationNum) & ".txt"
      Set filetxt = filesys.CreateTextFile(filename, True)
      path = filesys.GetAbsolutePathName(filename)
      getname = filesys.GetFileName(path)
      Dim n, nVal
      For n = 0 to 24
        If arraySize(n) > 0 then
          'filetxt.WriteLine( n & "," & arraySize(n))
          nval = array2val(n)
          filetxt.WriteLine( nval & "," & arraySize(n))
        End If
      Next
      ' filetxt.WriteLine("This is the pebblecount info.")
      filetxt.Close
      If filesys.FileExists(path) Then
        msgbox ("Your file, '" & getname & "', has been created.")
      End If
    '*****************
    '* the other operating system
    '*********************
	Case 3
      Dim TextPath, TextFile
      TextPath =  dataPath & "\" & strName & cstr(locationNum) & ".txt"
	  Set TextFile = Application.CreateAppObject("file")			
	  TextFile.Open TextPath, 2
      Dim m, mval
        For m = 0 to 24
          If arraySize(m) > 0 then
        	  'TextFile.WriteLine ( m & "," & arraySize(m))
               mval = array2val(m)
               TextFile.WriteLine ( mval & "," & arraySize(m))
    	  End If
  		Next
	    TextFile.Close	
    End Select
  objTheControls ("txtBoxD50").value = 0
  objTheControls("txtBoxD84").value = 0
  objTheControls ("Total").value = 0
  objTheControls ("txtSedType").value = 0
  OptionControls("txtEditLayer").value = ""
  'OptionControls("txt").value = 0
  Applet.Forms("frmGR").Close 
  call clearGSArray
  else
    exit sub
  End If 
End Sub ' end btnSave_Click

'*******
'clearGSArray - This procedure is called from the btnSave_Click procedure
'    in the Grainsize Analsis Tool.  It resets all values in the arraysize array
'    to zero.  
'*******
Sub clearGSArray
    Dim q 
    q = 0
    For q = 0 to 24
      arraySize(q) = 0
    Next
End Sub ' end clearGSArray

'*******
'Function array2str(x) 	This function is obsolete.
'  This function creates a short text string for array values.
'*******
Function array2string(x)
    If x =  1 Then
      array2string = "0.125-Very Fine Sand"
    ElseIf x = 2 Then
      array2string = "0.25-Fine Sand"
    ElseIf x = 3 Then
      array2string = "0.5-Medium Sand"
    ElseIf x = 4 Then
      array2string = "1.0-Coarse Sand"
    ElseIf x = 5 Then
      array2string = "2.0-Very Coarse Sand"
    ElseIf x = 6 Then
      array2string = "4.0-Fine Gravel"
    ElseIf x = 7 Then
      array2string =  "5.7-Fine Gravel"
    ElseIf x = 8 Then
      array2string = "8.0- Fine Gravel"
    ElseIf x = 9 Then
      array2string = "11.3-Medium Gravel"
    ElseIf x = 10 Then
      array2string = "16-Medium Gravel"
    ElseIf x = 11 Then
      array2string = "22.6-Coarse Gravel"
    ElseIf x = 12 Then
      array2string = "32-Coarse Gravel"
    ElseIf x = 13 Then
      array2string = "45-V Coarse Gravel"
    ElseIf x = 14 Then
      array2string = "64-V Coarse Gravel"
    ElseIf x = 15 Then
      array2string = "90-Small Cobble"
    ElseIf x = 16 Then
      array2string = "128-Small Cobble"
    ElseIf x = 17 Then
      array2string = "180-Large Cobble"
    ElseIf x = 18 Then
      array2string = "256-Large Cobble"
    ElseIf x = 19 Then
      array2string = "362-Small Boulder"
    ElseIf x = 20 Then
      array2string = "512-Small Boulder"
    ElseIf x = 21 Then
      array2string = "1024-Med Boulder"
    ElseIf x = 22 Then
      array2string = "2048-Large Boulder"
    ElseIf x = 23 Then
      array2string = "4096-V Lrg Boulder"
    ElseIf x = 24 Then
       array2string = "Bedrock"
    End If
End Function

'*******
'Function array2string(x) - This function creates a text string for array values.  
'         It is called by two procedures (btnSave_Click and recordMeasure) within 
'         the Grain Size Analysis Tool.  
'*******
Function array2str(x)
    If x =  1 Then
      array2str = "Silt/Clay"
    ElseIf x = 2 Then
      array2str = "VFSand"
    ElseIf x = 3 Then
      array2str = "FSand"
    ElseIf x = 4 Then
      array2str = "MSand"
    ElseIf x = 5 Then
      array2str = "CSand"
    ElseIf x = 6 Then
      array2str = "VCSand"
    ElseIf x = 7 Then
      array2str = "FGravel"
    ElseIf x = 8 Then
      array2str = "FGravel"
    ElseIf x = 9 Then
      array2str = "FGravel"
    ElseIf x = 10 Then
      array2str = "MGravel"
    ElseIf x = 11 Then
      array2str = "MGravel"
    ElseIf x = 12 Then
      array2str = "CGravel"
    ElseIf x = 13 Then
      array2str = "CGravel"
    ElseIf x = 14 Then
      array2str = "VCGravel"
    ElseIf x = 15 Then
      array2str = "VCGravel"
    ElseIf x = 16 Then
      array2str = "SCobble"
    ElseIf x = 17 Then
      array2str = "SCobble"
    ElseIf x = 18 Then
      array2str = "LCobble"
    ElseIf x = 19 Then
      array2str = "LCobble"
    ElseIf x = 20 Then
      array2str = "SBoulder"
    ElseIf x = 21 Then
      array2str = "SBoulder"
    ElseIf x = 22 Then
      array2str = "MBoulder"
    ElseIf x = 23 Then
      array2str = "LBoulder"
    ElseIf x = 24 Then
      array2str = "VLBoulder"
    ElseIf x = 25 Then
       array2str = "Bedrock"
    End If
End Function

'*******
'Function array2val(x) 	This function creates a numerical text string to describe
'         grain size.  It is called by the btnSave_Click procedure within the
'         Grain Size Analysis Tool.  	
'*******
Function array2val(x)
    If x =  1 Then
      array2val = "0.125"
    ElseIf x = 2 Then
      array2val = "0.25"
    ElseIf x = 3 Then
      array2val = "0.5"
    ElseIf x = 4 Then
      array2val = "1.0"
    ElseIf x = 5 Then
      array2val = "2.0"
    ElseIf x = 6 Then
      array2val = "4.0"
    ElseIf x = 7 Then
      array2val = "5.7"
    ElseIf x = 8 Then
      array2val = "8.0"
    ElseIf x = 9 Then
      array2val = "11.3"
    ElseIf x = 10 Then
      array2val = "16"
    ElseIf x = 11 Then
      array2val = "22.6"
    ElseIf x = 12 Then
      array2val = "32"
    ElseIf x = 13 Then
      array2val = "45"
    ElseIf x = 14 Then
      array2val = "64"
    ElseIf x = 15 Then
      array2val = "90"
    ElseIf x = 16 Then
      array2val = "128"
    ElseIf x = 17 Then
      array2val = "180"
    ElseIf x = 18 Then
      array2val = "256"
    ElseIf x = 19 Then
      array2val = "362"
    ElseIf x = 20 Then
      array2val = "512"
    ElseIf x = 21 Then
      array2val = "1024"
    ElseIf x = 22 Then
      array2val = "2048"
    ElseIf x = 23 Then
      array2val = "4096"
    ElseIf x = 24 Then
       array2val = "9999"
    End If
End Function

' Spatial Note - 
'                This note will record up to 254 characters.
'************************************************************
'setInitialLayerSN - This procedure is called during the the Spatial FieldNote
'      Form onload event.  In this procedure, global variables are set to define
'      forms and control objects.  This procedure then determines if a editable
'      map layer exists and if this map layer or shape file contains the
'      corresponding fields for this tool.  If these quality control requirements
'      are not met, the user is informed and the procedure is exited.  Because
'      this tool can be used to append an existing record, if the selected record
'     is new, the returnNextID function is called and the identity field of the
'     shapefile record is updated.  
'*******
Sub setInitialLayerSN
  'Get a reference to the form and controls
  'These objects are declared globally, so this is only necessary once
    Set objTheForm = ThisEvent.Object
    Set objTheControls = objTheForm.Pages("pgNoteBook").Controls
    objTheControls ("txtBoxNote").value = ""
    ' determine if one layer is an editable layer
    Dim objSelLayer
    ' The layer being edited is -- objSelLayer  --
    'Get the layer of the selected feature
    Set objSelLayer = Map.SelectionLayer
    'If there is no selection, exit the Sub
    If objSelLayer Is Nothing Then 
      MsgBox "No feature has been selected.", vbInformation, "No Selection"
      Applet.Forms("frmFN").Close (True) 
      Exit Sub
    End If    '**************************************
  Dim F, intFieldNotes
  intFieldNotes = 0
  For each F in objSelLayer.Records.Fields
    If F.Name = "MYNOTE" Then  
        intFieldNotes = intFieldNotes + 1
    End If
    If F.Name = "DATE_" Then  
        intFieldNotes = intFieldNotes + 1
    End If  
  Next
  'If the required fields do not exist send a warning.
  If intFieldNotes < 2 Then
    MsgBox "The selected layer does not contain myNotes or Date fields.", vbExclamation, "No Numeric Fields"
    Applet.Forms("frmNoteBook").Close (True) 
    Exit Sub
  End if
  '**************************************
  ' find identity of selected feature
   Dim pRS 
   Set pRS = Map.SelectionLayer.Records
   pRS.Bookmark = Map.SelectionBookmark
   'user notification
    'Application.MessageBox CStr(pRS.Fields(1).Value)

   if CStr(pRS.Fields(1).Value) = "0" then 
     Dim ptNumValue
     ptNumValue = ReturnNextID(pRS, "ID")
     objTheControls("txtID").value = ptNumValue
'     pRS.Fields("ID").value = ptNumValue
 '    pRS.update
   else
     objTheControls("txtID").value = pRS.Fields(1).Value
     objTheControls("txtBoxNote").value = pRS.Fields(4).Value

   end if
   'user notification
   'Application.MessageBox CStr(pRS.Fields(2).Value)
   'Application.MessageBox CStr(pRS.Fields(3).Value)
   Set prs = nothing   
End Sub ' end setInitialLayerSN

'*******
'OpenFormFN - This procedure is called when the Field Note icon of the strAss
'          Toolbar is tapped.  The mapLayer Count Function is called; if the return
'          value is greater than zero, this procedure opens the form.  
'*******
Sub OpenFormFN
  Dim shpOptControls
  'Called when the pencil button is clicked/tapped
  'If there are no layers in the map, then exit (no statistics to calculate).
  Dim myMapLayerCount
  ' call to Function "MapLayerCount"
  myMapLayerCount = mapLayerCount
  If myMapLayerCount > 0 Then
    ' show the form.
     Applet.Forms("frmFN").show 
  End If
End Sub ' End OpenFormFN

'*******
'NoteSave - This procedure is called by the SAVE button in the Spatial FieldNotes
'         Tool.  It records the date, time, point location, and the text string 
'         provided by the user to the shape file.  
'*******
Sub NoteSave
 
  dblX = Map.PointerX
  dblY = Map.PointerY
  
   'record your values to shapefile
   Dim objRS, theDate, theTime, txtNote
   Set objRS = Map.SelectionLayer.Records 
   objRS.Bookmark = Map.SelectionBookmark
   theTime = FormatDateTime(Now,vbLongTime)

   Set ctrls = Applet.Forms("frmFN").Pages("pgNoteBook").Controls
   theDate = ctrls("dtpDate_Field").value 
   txtNote = ctrls("txtBoxNote").value 
   locationNum = ctrls("txtID").value

   'objRS.addnew
   objRS.Fields("Date_").value = theDate
   objRS.Fields("mynote").value = txtNote
   objRS.Fields("strTime").value = theTime
   objRS.Fields("ID").value = locationNum
   objRS.Fields("x").value = dblX
   objRS.Fields("y").value = dblY
   objRS.update
   Set objRS = nothing
   Applet.Forms("frmFN").Close (True) 
   Application.ExecuteCommand("clearselected") 
End Sub ' End Note Save

'**********************************************************************************
' Functions Used by All
'********************

'Function mapLayerCount - This  function counts the number of map layers loaded
'         into the current ArcPad instance.  It is called by the OpenFormXS, 
'         OpenFormQW, OpenFormGR, and OpenFormFN procedures.  
'*******
Function mapLayerCount
  If Map.Layers.Count = 0 Then
    MsgBox "The current map does not contain any layers.", vbExclamation, "No Layers"
    MapLayerCount = 0
  Else  
  ' If there are no shapefile layers in the map, then exit (no statistics to calculate).
  Dim L
  For Each L in Map.Layers
    If (L.LayerFormat = "SHAPEFILE") Then
      MapLayerCount = MapLayerCount + 1
      Exit For
    End If
  Next
    If MapLayerCount = 0 Then
      MsgBox "The current map does not contain any shapefile layers.", vbExclamation, "No Shapefile Layers"
    End If
  End If
End Function

'*******
'Function mapLayerEdit - This  function is obsolete.  
'        This function determines if one of the map layers loaded into the current
'        ArcPad instance is set in the edit mode.  It is replaced by a line of 
'        code that queries the status of the Map.SelectionLayer in the 
'        setInitialLayersXS, setInitialLayersQW, setInitialLayersGR, and 
'        setInitialLayersFN procedures.  
'*******
Function mapLayerEdit
  MapLayerEdit = 0
 ' determine if one layer is an editable layer
   Dim objSelLayer
   'Get the layer of the selected feature
   Set objSelLayer = Map.SelectionLayer
   
   'If there is no selection, exit the Sub
   If objSelLayer Is Nothing Then 
      MsgBox "No feature has been selected.", vbInformation, "No Selection"
      MapLayerEdit = 0
   Else
     MapLayerEdit = 1
   End If

End Function
